﻿{*******************************************************}
{                                                       }
{       DelphiWebMVC 5.0                                }
{       E-Mail:pearroom@yeah.net                        }
{       版权所有 (C) 2022-2 苏兴迎(PRSoft)              }
{                                                       }
{*******************************************************}
unit MVC.Controller;

interface

uses
  System.Classes, System.SysUtils, System.JSON, System.Net.URLClient, MVC.JSON,
  System.Net.HttpClientComponent, IdURI, mvc.Config, MVC.TplParser, IdGlobal,
  MVC.Session, MVC.TplUnit, MVC.LogUnit, MVC.DataSet, mvc.Tool, System.Rtti,
  MVC.HttpMmt, mvc.BaseModel, mvc.Redis, REST.JSON;

type
  THTTPMethod = (_STOP, _ALL, _GET, _POST, _PUT, _HEAD, _DELETE, _PATCH, _OPTIONS);

  TMURL = class(TCustomAttribute)
  private
    httpMethod: THTTPMethod;
    function FmtURL(url: string): string;
  public
    routeUrl: string;
    tplPath: string;
    function getMethodType: string;
    constructor Create(sRouteUrl: string; sMethod: THTTPMethod = THTTPMethod._ALL); overload;
    constructor Create(sMethod: THTTPMethod = THTTPMethod._ALL); overload;
    constructor Create(sRouteUrl: string; sTplPath: string; sMethod: THTTPMethod = THTTPMethod._ALL); overload;
  end;

  TMDoc = class(TCustomAttribute)
  private
    FT: TClass;
  public
    function getDoc(path: string): string;
    constructor Create(T: TClass);
  end;

  TTable = class(TCustomAttribute)
  private
  public
    FTableName: string;
    constructor Create(TableName: string);
  end;

  TController = class
  private
    PageParams: TStringList;
    FRequest: TWebRequest;
    FResponse: TWebResponse;
    FWebPath: string;
    FRouteUrl: string;
    FtplPath: string;
    FSession: TSession;
    FMethodName: string;
    FTableName: string;
    procedure SetRequest(const Value: TWebRequest);
    procedure SetResponse(const Value: TWebResponse);
    procedure SetRouteUrl(const Value: string);
    procedure SettplPath(const Value: string);
    procedure SetMethodName(const Value: string);
    procedure SetTableName(const Value: string);

  public
    property TableName: string read FTableName write SetTableName;
    property Session: TSession read FSession;
    property WebPath: string read FWebPath; //系统物理根目录
    property Request: TWebRequest read FRequest write SetRequest;
    property Response: TWebResponse read FResponse write SetResponse;
    property RouteUrl: string read FRouteUrl write SetRouteUrl;
    property MethodName: string read FMethodName write SetMethodName;
    property tplPath: string read FtplPath write SettplPath;
    procedure CreateController; virtual; //控制器创建
    function Intercept(): Boolean; virtual; //访问拦截处理方法需子类继承使用
    procedure Show(htmlTpl: string);
    function InputToJSON: IJObject;
    function InputJSON: string;  //返回请求内容
  protected
    function Q(str: string): string;
    function UpFiles(filedir: string = ''; filename: string = ''): string; //接收上传文件
    function GetGUID: string;
    function Input(param: string): string;
    function InputByIndex(index: Integer): string;
    function InputBody: string;  //返回请求内容
    function JSONToObject<T: class, constructor>(AJsonObject: TJSONObject): T;
    function InputToObject<T: class, constructor>(): T;
    function InputToJSONArray: IJArray;
    function InputToObj<T>(): T;
    function InputInt(param: string): Integer;

    procedure SetAttr(key: string; ds: IDataSet); overload;
    procedure SetAttr(key, value: string); overload;
    procedure SetAttr(key: string; json: IJObject); overload;
    procedure SetAttr(key: string; JsonArray: IJArray); overload;
    procedure ShowText(text: string);
    procedure ShowXMLTpl(xmlTpl: string);
    procedure ShowXML(xml: string);
    procedure ShowJSON(json: string); overload;
    procedure ShowJSON(jsonJO: IJObject); overload;
    procedure ShowJSON(jsonJA: IJArray); overload;
    procedure ShowJSON(dataset: IDataSet); overload;
    procedure ShowJSON(res: TResData); overload;

    procedure ShowFile(AFileName: string; isDown: Boolean = false);  /// <param name="isdown">是否下载文件</param>
    procedure Success(code: Integer = 0; msg: string = '');
    procedure Fail(code: Integer = -1; msg: string = '');
    procedure Redirect(action: string; path: string = '');

    function GetHeader(key: string): string;
    procedure WriteHeader(key: string; value: string);

    destructor Destroy; override;
  end;

implementation

{ TBaseController }

function TController.GetGUID: string;
var
  LTep: TGUID;
  sGUID: string;
begin
  CreateGUID(LTep);
  sGUID := GUIDToString(LTep);
  sGUID := StringReplace(sGUID, '-', '', [rfReplaceAll]);
  sGUID := Copy(sGUID, 2, Length(sGUID) - 2);
  result := sGUID;
end;

function TController.GetHeader(key: string): string;
begin
  Result := Request.GetHeader(key);
end;

procedure TController.CreateController;
begin
  FWebPath := Config.BasePath;
  PageParams := TStringList.Create;
  FSession := TSession.Create(Request, Response);
end;

destructor TController.Destroy;
begin

  if Assigned(FSession) then
    FSession.Free;
  if Assigned(PageParams) then
  begin
    PageParams.Clear;
    PageParams.Free;
  end;
  inherited;
end;

procedure TController.Fail(code: Integer; msg: string);
var
  jo: IJObject;
begin
  jo := IIJObject();
  if Trim(msg) = '' then
    msg := '操作失败';
  jo.O.AddPair('code', TJSONNumber.Create(code));
  jo.O.AddPair('message', msg);
  ShowJSON(jo);
end;

function TController.Intercept: Boolean;
begin
  Result := False;
end;

function TController.JsonToObject<T>(AJsonObject: TJSONObject): T;
begin
  Result := TJson.JsonToObject<T>(InputToJSON.O);
end;

function TController.Q(str: string): string;
begin
  result := QuotedStr(str);
end;

procedure TController.Redirect(action, path: string);
var
  S: string;
begin
  S := Config.APP + '/';
  if action.Trim <> '' then
    S := S + action + '/';
  if path.Trim <> '' then
    S := S + path;
  Response.SendRedirect(S);
  ShowText(S);
end;

procedure TController.SetAttr(key: string; json: IJObject);
begin
  if json <> nil then
  begin
    setAttr(key, json.toJSON);
  end;
end;

procedure TController.SetAttr(key, value: string);
begin
  if value.Trim = '' then
    value := ' ';
  PageParams.Values[key] := value;
end;

procedure TController.SetRequest(const Value: TWebRequest);
begin
  FRequest := Value;
end;

procedure TController.SetResponse(const Value: TWebResponse);
begin
  FResponse := Value;
end;

procedure TController.SetRouteUrl(const Value: string);
begin
  FRouteUrl := Value;
end;

procedure TController.SetTableName(const Value: string);
begin
  FTableName := Value;
end;

procedure TController.SettplPath(const Value: string);
begin
  FtplPath := Value;
end;

procedure TController.ShowFile(AFileName: string; isDown: Boolean);
var
  sFileName: string;
begin
  sFileName := AFileName;
  if ExtractFileDrive(sFileName) = '' then
    sFileName := Config.WebRoot + sFileName;

  sFileName := sFileName.Replace('/', '\');
  Response.Content := sFileName;
  Response.ContentType := '!STATICFILE';
  if not isDown then
    //浏览器内显示
    Response.SetCustomHeader('Content-Disposition', 'inline;filename=' + ExtractFileName(sFileName))
  else
    //下载文件
    Response.SetCustomHeader('Content-Disposition', 'attachment;filename=' + ExtractFileName(sFileName));

  Response.ContentEncoding := Config.document_charset;
end;

procedure TController.Show(htmlTpl: string);
var
  key, pagefile: string;
  htmlcontent: string;
  pagepars: TTplParser;
  suff: string;
begin

  if Response.Sent then
    exit;

  if htmlTpl.Trim = '' then
    exit;

  suff := '';
  if Pos('.', htmlTpl) < 1 then
  begin
    suff := Config.template_type;
  end;

  htmlTpl := htmlTpl.Replace('/', '\');
  if htmlTpl.Substring(0, 1) = '\' then
  begin
    key := htmlTpl + suff;
  end
  else
  begin
    if tplPath <> '' then
      tplPath := tplPath + '\';
    key := tplPath + htmlTpl + suff;
  end;
  pagefile := Config.BasePath + config.WebRoot + '\' + Config.template + '\' + key;
  pagefile := IITool.PathFmt(pagefile);
  try
    htmlcontent := PageCache.LoadPage(pagefile);
    if htmlcontent = '' then
    begin
      Response.StatusCode := 400;
      htmlcontent := '<h1>接口方法不存在</h1><hr>' + self.FRequest.URL;
    end
    else
    begin
      pagepars := TTplParser.Create;
      try
        pagepars.Parser(htmlcontent, PageParams, tplPath);
      finally
        pagepars.Free;
      end;
    end;
  finally
    Session.CreateSessionCookie;
    Response.ContentType := 'text/html; charset=' + Config.document_charset;
    Response.Content := htmlcontent;
  end;
end;

procedure TController.ShowJSON(dataset: IDataSet);
begin
  if dataset = nil then
    ShowJSON('[]')
  else
  begin
    ShowJSON(dataset.toJSONArray);
    dataset := nil;
  end;
end;

procedure TController.ShowJSON(res: TResData);
begin
  Success(res.Code, res.message);
end;

procedure TController.ShowJSON(jsonJA: IJArray);
begin
  ShowJSON(jsonJA.ToJSON);
end;

procedure TController.ShowJSON(jsonJO: IJObject);
begin
  ShowJSON(jsonJO.toJSON);
end;

procedure TController.ShowJSON(json: string);
begin
 // Corss_Origin;
  Response.ContentType := 'application/json; charset=' + Config.document_charset;
  Response.Content := json;
end;

procedure TController.ShowText(text: string);
begin
//  Corss_Origin;
  Response.ContentType := 'text/html; charset=' + Config.document_charset;
  Response.Content := text;
end;

function TController.InputInt(param: string): Integer;
begin
  Result := StrToInt(Input(param));
end;

function TController.InputJSON: string;
begin
  Result := InputToJSON.toJSON();
end;

function TController.InputBody: string;
begin
  Result := Request.Content;
end;

function TController.InputByIndex(index: Integer): string;
var
  s, s1: string;
  params: TStringList;
  k: integer;
begin
  params := TStringList.Create;
  try
    s1 := RouteUrl;
    s := Request.PathInfo;
    k := Pos(MethodName, s);
    if k > 0 then
    begin
      s1 := s.Substring(0, k + MethodName.Length);
    end;
    s := s.Replace(s1, '', [rfIgnoreCase, rfReplaceAll]);
    params.Delimiter := '/';
    params.DelimitedText := s;
    if (index < params.Count) and (index > -1) then
    begin
      s := params.Strings[index];
    end
    else
    begin
      s := '';
    end;
    Result := s;
  finally
    params.Free;
  end;
end;

function TController.InputToJSON: IJObject;
var
  jo: IJObject;
  i, j, con: Integer;
  isok: boolean;
  key, value, key2: string;
  body: string;
begin
  isok := False;
  body := InputBody;
  con := Request.ContentFields.Count;
  try
    if body.Trim <> '' then
    begin
      if (body.Substring(0, 1) = '[') and (body.Substring(body.Length - 1, 1) = ']') then
        exit;   //不处理json数组由InputToJSONArray处理
      if (body.Substring(0, 1) = '{') and (body.Substring(body.Length - 1, 1) = '}') then
      begin
        try
          jo := IIJObject(body);
          isok := true;
        except
          jo := nil;
        end;
      end
      else if con > 0 then
      begin
        jo := IIJObject();
        for i := 0 to con - 1 do
        begin
          key := Request.ContentFields.Names[i];
          if key <> '' then
          begin
            value := Request.ContentFields.ValueFromIndex[i];
            if i < con - 2 then
            begin
              for j := i + 1 to con - 1 do
              begin
                key2 := Request.ContentFields.Names[j];
                if key2 <> '' then
                  break
                else
                  value := value + #13#10 + Request.ContentFields.Strings[j];
              end;
            end;
          end;
          if (key.Trim <> '') and (value.Trim <> '') then
          begin
            isok := True;
            jo.O.AddPair(key, value);
          end;
        end;
      end;
    end
    else
    begin
      jo := IIJObject();
      for i := 0 to Request.QueryFields.Count - 1 do
      begin
        key := Request.QueryFields.Names[i];
        value := Request.QueryFields.ValueFromIndex[i];
        if (key.Trim <> '') and (value.Trim <> '') then
        begin
          jo.O.AddPair(key, value);
          isok := True;
        end;
      end;
    end;
  finally
    if not isok then
      jo := IIJObject('{}');
    Result := jo;
  end;
end;

function TController.InputToJSONArray: IJArray;
var
  ja: IJArray;
  body: string;
begin
  body := InputBody;
  if body.Trim <> '' then
  begin
    if (body.Substring(0, 1) = '[') and (body.Substring(body.Length - 1, 1) = ']') then
    begin
      try
        ja := IIJArray(body);
      except
        ja := nil;
      end;
    end
  end;
  Result := ja;
end;

function TController.InputToObj<T>: T;
var
  jo: IJObject;
  value: T;
  _rtti: TRttiContext;
  tt: TRttiType;
  fields: TArray<TRttiField>;
  field: TRttiField;
  json,key, ty: string;
begin
  value := Default(T);
  json:=InputBody;
  if json <> '' then
  begin
    tt := _rtti.GetType(TypeInfo(T));
    fields := tt.GetFields;
    jo := IIJObject(json);
    for field in fields do
    begin
      key := field.Name;
      ty := field.FieldType.ToString;
       if jo.O.Get(key) <> nil then
      begin
        if ty = 'string' then
          field.SetValue(@value, jo.S[key])
        else if ty = 'integer' then
          field.SetValue(@value, jo.I[key])
        else if ty = 'boolean' then
          field.SetValue(@value, jo.B[key])
        else if Pos('double,float', ty) > -1 then
          field.SetValue(@value, jo.D[key])
      end;
    end;
    Result := value;
  end
  else
    result := value;
end;

function TController.InputToObject<T>: T;
begin
  Result := JsonToObject<T>(InputToJSON.O);
end;

function TController.Input(param: string): string;
begin
  Result := InputToJSON.S[param];
end;

procedure TController.ShowXML(xml: string);
begin
  Response.ContentType := 'application/xml; charset=' + Config.document_charset;
  Response.Content := xml;
end;

procedure TController.ShowXMLTpl(xmlTpl: string);
var
  key, xmlcontent: string;
  pagepars: TTplParser;
  pagefile: string;
  page: TPage;
  suff: string;
begin
 // Corss_Origin;

  if xmlTpl.Trim = '' then
    exit;

  suff := '';
  if Pos('.', xmlTpl) < 1 then
  begin
    suff := '.xml';
  end;

  xmlTpl := xmlTpl.Replace('/', '\');
  if xmlTpl.Substring(0, 1) = '\' then
  begin
    key := xmlTpl + suff;
  end
  else
  begin
    if tplPath <> '' then
      tplPath := tplPath + '\';
    key := tplPath + xmlTpl + suff;
  end;

  xmlcontent := PageCache.LoadPage(key);
  if xmlcontent <> '' then
  begin
    pagepars := TTplParser.Create;
    try
      pagepars.Parser(xmlcontent, PageParams, tplPath);
    finally
      pagepars.Free;
    end;
    ShowXML(xmlcontent);
  end;

  if xmlcontent.Trim = '' then
  begin
    Response.StatusCode := 404;
    pagefile := WebPath + config.WebRoot + '\' + Config.Error404 + Config.template_type;
    page := TPage.Create(pagefile);
    try
      xmlcontent := page.Error404(key);
    finally
      page.Free;
    end;
    ShowText(xmlcontent);
  end;
end;

procedure TController.Success(code: Integer; msg: string);
var
  jo: IJObject;
begin
  jo := IIJObject();
  if Trim(msg) = '' then
    msg := '操作成功';
  jo.O.AddPair('code', TJSONNumber.Create(code));
  jo.O.AddPair('message', msg);
  ShowJSON(jo);
end;

function TController.UpFiles(filedir: string = ''; filename: string = ''): string;
var
  k: integer;
  path, s, FFileName: string;
  Afile: TFileStream;
  i: Integer;
  p, ret, filetmp: string;
begin
  k := Request.Files.Count - 1;
  if k = -1 then
  begin
    ret := '';
    Result := ret;
    exit;
  end;
  for i := 0 to k do
  begin
    s := ExtractFileName(Request.Files[i].filename);
    if (s <> '') then
    begin
      if filedir.Trim <> '' then
        path := WebPath + filedir.Trim
      else
        path := WebPath + 'upfile';
      if not DirectoryExists(path) then
      begin
        CreateDir(path);
      end;

      if filename.Trim <> '' then
      begin
        p := '';
        if i > 0 then
          p := i.ToString;
        filetmp := filename.Trim + p + copy(s, Pos('.', s), s.Length - pos('.', s) + 1)
      end
      else
      begin
        filetmp := GetGUID + copy(s, Pos('.', s), s.Length - pos('.', s) + 1);
      end;
      FFileName := path + '\' + filetmp;
      Afile := TFileStream.Create(FFileName, fmCreate);
      try
        Request.Files[i].Stream.Position := 0;
        Afile.CopyFrom(Request.Files[i].Stream, Request.Files[i].Stream.Size);  //测试保存文件，通过。
      finally
        Afile.Free;
      end;
      ret := ret + filetmp + ',';
    end;
  end;
  if (ret.Length > 0) then
    ret := ret.Substring(0, ret.Length - 1);
  Result := ret;
end;

procedure TController.WriteHeader(key, value: string);
begin
  Response.SetCustomHeader(key, value);
end;

procedure TController.SetAttr(key: string; JsonArray: IJArray);
begin
  if JsonArray <> nil then
  begin
    setAttr(key, JsonArray.toJSON);
  end;
end;

procedure TController.SetMethodName(const Value: string);
begin
  FMethodName := Value;
end;

procedure TController.SetAttr(key: string; ds: IDataSet);
begin
  setAttr(key, ds.toJSONArray);
end;

constructor TMURL.Create(sMethod: THTTPMethod);
begin
  routeUrl := '';
  tplPath := '';
  httpMethod := sMethod
end;

function TMURL.FmtURL(url: string): string;
var
  s: string;
begin
  s := url;
  if s.Trim <> '' then
  begin
    s := s.Replace('\\', '/').Replace('//', '/').Replace('\', '/');
    if s.Substring(0, 1) = '/' then
      s := s.Substring(1, s.Length);
    if s.Substring(s.Length - 1, 1) = '/' then
      s := s.Substring(0, s.Length - 1);
  end;
  Result := s;
end;

constructor TMURL.Create(sRouteUrl: string; sMethod: THTTPMethod);
begin

  routeUrl := FmtURL(sRouteUrl);
  tplPath := '';
  httpMethod := sMethod
end;

constructor TMURL.Create(sRouteUrl, sTplPath: string; sMethod: THTTPMethod);
begin
  routeUrl := FmtURL(sRouteUrl);
  tplPath := FmtURL(sTplPath);
  httpMethod := sMethod
end;

function TMURL.getMethodType: string;
begin
  Result := '';
  case httpMethod of
    _STOP:
      result := 'STOP';
    _GET:
      result := 'GET';
    _POST:
      result := 'POST';
    _PUT:
      result := 'PUT';
    _HEAD:
      result := 'HEAD';
    _DELETE:
      result := 'DELETE';
    _PATCH:
      result := 'PATCH';
    _OPTIONS:
      result := 'OPTIONS';
  end;
end;

{ TMDoc }

constructor TMDoc.Create(T: TClass);
begin
  FT := T;
end;

function TMDoc.getDoc(path: string): string;
var
  _RTTIContext: TRttiContext;
  _type: TRttiType;
  _proper: TRttiField;
 // _method: TRttiMethod;
  json, json1: string;
  key, value: string;
 // tk: TTypeKind;
  //_value: TValue;
  f, f1: TCustomAttribute;
 // k: integer;
begin
  _type := _RTTIContext.GetType(FT);
  key := '"' + path + '"';
 // k := length(_type.GetAttributes);
  for f1 in _type.GetAttributes do
  begin
    if f1 is TRemarks then
    begin
      with TRemarks(f1) do
      begin
        value := '"' + FText + '"';
      end;
    end;
  end;
  if value = '' then
    value := '"描述为空"';
  json1 := key + ':' + value + ',';
  for _proper in _type.GetFields do
  begin
    key := '"' + (_proper.Name) + '"';
 //   k := length(_proper.GetAttributes);
    for f in _proper.GetAttributes do
    begin
      if f is TRemarks then
      begin
        with TRemarks(f) do
        begin
          value := FText;
          if FType.Trim = '' then
            FType := _proper.FieldType.Name;
          value := value + '[' + FType + ']';
          value := '"' + trim(value) + '"';
        end;
        json := json + key + ':' + value + ',';
      end;
    end;
  end;
  json := json.Substring(0, json.Length - 1);
  if json <> '' then
    json := '{' + json + '}'
  else
    json := '{}';
  json1 := json1 + '"Params":' + json;
  json1 := '{' + json1 + '}';
  Result := json1;
end;

{ TTable }

constructor TTable.Create(TableName: string);
begin
  FTableName := TableName;
end;

end.

